; ORIGINAL: 3dt2.1/examples/acis.scm
; $Id: acis.scm,v 1.7 1997/04/30 20:24:04 jread Exp $
;======================================================================
; Purpose---
;    Useful scheme procedures for running the ACIS 3D Toolkit
;
;======================================================================

(provide 'acis)

(load "colors.scm")
(load "math.scm")
(load "setview.scm")
(load "pick.scm")
(load "wcs.scm")

;; Viewing
(load "pan.scm")
(load "rotsph.scm")
(load "zoom.scm")

;; Useful aliases for #t and #f
(define ON #t)
(define OFF #f)

;;----------------------------------------------------------------------
;; The variable print-length controls printing of lists.  This command
;; causes only the first 20 elements of a list to be printed.
(set! print-length 20)

;;----------------------------------------------------------------------
;; Supress notification when garbage collecting is done.
(set! garbage-collect-notify? #f)

;;----------------------------------------------------------------------
;; some useful macros

;; Implement a simple while loop
(define-macro (while test . body)
  `(let loop ()
     (cond (,test ,@body (loop)))))

;; Implement a simple loop like the C for loop
(define-macro (for init test incr . body)
  `(let loop (,init)
     (cond (,test ,@body (loop ,incr)))))

;;----------------------------------------------------------------------
;; define a line drawing procedure
(define line (lambda l
               (let ((pt1 #f)
                     (pt2 #f))
                 (if (not (null? l))
                     (begin
                       (set! pt1 (car l))
                       (if (procedure? pt1) (set! pt1 (pt1)))
                       (set! l (cdr l))
                       (if (not (null? l))
                           (begin
                             (set! pt2 (car l))
                             (if (procedure? pt2)
                                 (begin
                                   (rbd:line ON pt1)
                                   (set! pt2 (pt2))
                                   (rbd:remove-type rbd:line?)))))))
                 (if (not pt1) (set! pt1 (~p)))
                 (if (not pt2)
                     (begin
                       (rbd:line ON pt1)
                       (set! pt2 (~p))
                       (rbd:remove-type rbd:line?)))
                 (edge:linear pt1 pt2))))


;; create a polyline
(define polyline (lambda close
                   (roll:mark-start)
                   (do ((start #f (if (not start) (position:copy pt2) start))
                        (pt1 #f (position:copy pt2))
                        (pt2 (~p) (~p))
                        (ename #f)
                        (elist (list) (if ename (cons ename elist) elist))
                        )
                       ((eq? pt2 #f)
                        (if (and (not (null? close)) elist start pt1)
                            (set! elist (cons (edge:linear pt1 start) elist)))
                        (roll:mark-end)
                        (rbd:remove-type rbd:line?)
                        (reverse elist))
                       (rbd:remove-type rbd:line?)
                       (if pt1 (set! ename (edge:linear pt1 pt2)))
                       (rbd:line ON pt2))))


;; create a block of a given thickness and two corners of the base
(define block
  (lambda (d . pts)
    (let* ((pt1 (if (null? pts) (~p) (car pts)))
           (pt2 (if (< (length pts) 2) (~rrp pt1) (cadr pts))))
      (solid:block pt1 (position:offset pt2 (gvector 0 0 d))))))

;; create a cylinder of a given radius and height
(define cylinder (lambda (r d . pt)
                   (let ((p1 (if (null? pt) (~p) (car pt))))
                     (solid:cylinder p1
                                     (position:offset p1 (gvector 0 0 d))
                                     r))))

;; create a cone of a given height
(define cone (lambda (r1 r2 d . pt)
               (let ((p1 (if (null? pt) (~p) (car pt))))
                 (solid:cone p1
                             (position:offset p1 (gvector 0 0 d))
                             r1 r2))))

;; create a sphere of a given radius
(define sphere (lambda (r . pt)
                 (let ((p1 (if (null? pt) (~p) (car pt))))
                   (solid:sphere p1 r))))

;; create a polyline and sweep it into a solid
(define sweep (lambda (h)
                (solid:sweep-face
                  (car (entity:faces
                         (api_cover_wires
                           (wire-body
                             (polyline #t))))) h)))

;; define some rectangle creation routines
(define rectangle
  (lambda l
    (let ((p1 #f)
          (p2 #f))
      (roll:mark-start)
      (if (not (null? l))
          (begin
            (set! p1 (car l))
            (if (procedure? p1) (set! p1 (p1)))
            (set! l (cdr l))
            (if (not (null? l))
                (begin
                  (set! p2 (car l))
                  (if (procedure? p2)
                      (begin
                        (rbd:rectangle ON p1)
                        (set! p2 (p2))
                        (rbd:remove-type rbd:rectangle?)))))))
      (if (not p1) (set! p1 (~p)))
      (if (not p2) (set! p2 (~rrp p1)))
      (let* ((name-list (list))
             (xmin (min (position:x p1) (position:x p2)))
             (ymin (min (position:y p1) (position:y p2)))
             (z (position:z p1))
             (xmax (max (position:x p1) (position:x p2)))
             (ymax (max (position:y p1) (position:y p2)))
             (pt1 (position xmin ymin z))
             (pt2 (position xmin ymax z)))
        (set! name-list (cons (edge:linear pt1 pt2) name-list))
        (set! pt1 (position:copy pt2))
        (position:set-x! pt2 xmax)
        (set! name-list (cons (edge:linear pt1 pt2) name-list))
        (set! pt1 (position:copy pt2))
        (position:set-y! pt2 ymin)
        (set! name-list (cons (edge:linear pt1 pt2) name-list))
        (set! pt1 (position:copy pt2))
        (position:set-x! pt2 xmin)
        (set! name-list (cons (edge:linear pt1 pt2) name-list))
        (roll:mark-end)
        (reverse name-list)
        ))))


;;----------------------------------------------------------------------
(define zoom
  (lambda (zoom-scale . v)
    (let ((view (if (not (null? v)) (car v) (env:active-view)))
          (scale (max .001 zoom-scale))
          )
      (view:set-size (/ (view:width view) scale)
                     (/ (view:height view) scale)
                     view)
      (view:refresh view)
      )))

;; Zoom in on a window
(define (zoom-window) (let ((w (get-window)))
                        (view:refresh (view:zoom-window (car w) (cdr w)))))

(define (zoom-all . v)
  (let ((view (if (not (null? v)) (car v) (env:active-view))))
    (view:compute-extrema view)
    (view:set-size (* (view:width view) 1.05)
                   (* (view:height view) 1.05)
                   view)
    (view:refresh view)
    ))

;======================================================================
;; Turn on camera rubberband driver.
(define (rb-camera mode)
  (if mode
      (begin
        (set! mouse-down-hook
              (lambda (pe)
                (let ((dynsil (dl:dynamic-silhouette-display #f)))
                  (rbd:clear)
                  (rbd:view #t pe mode)
                  (set! mouse-up-hook
                        (lambda (pe)
                          (rbd:clear)
                          (dl:dynamic-silhouette-display dynsil)
                          (view:refresh (event:view pe))
                          ))
                  )))
        (set! mouse-up-hook #f)
        )
      (begin
        (set! mouse-down-hook #f)
        (set! mouse-up-hook #f)
        )
      ))


